home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / load.t < prev    next >
Text File  |  1988-02-05  |  17KB  |  406 lines
  1. (herald load (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; globaL table of loaded modules
  27. ;;; each env has a list of instantiated modules
  28.  
  29. ;;;; LOAD and friends.
  30.  
  31. ;;; The main confusion to surmount before understanding this code
  32. ;;; is that when you ask to load a file, there are about five
  33. ;;; different filenames potentially involved, and the trick is to
  34. ;;; keep them all straight and to check consistency at the right
  35. ;;; places.
  36. ;;; These names are:
  37. ;;;   (a) The name appearing in the source file's HERALD.
  38. ;;;   (b) The name by which the compiler found the source file.
  39. ;;;   (c) The name of the file the compiler wrote.
  40. ;;;   (d) The name by which the file was found at load time.
  41. ;;;   (e) The name given in the REQUIRE form (this is obsolescent).
  42. ;;; (Also note that in cases (b), (c), and (d), there are really
  43. ;;; two file names involved, the "given name" and the "true name";
  44. ;;; but the current filename facility doesn't make that distinction
  45. ;;; yet.)
  46.  
  47.  
  48. ;;; Entry points for LOAD
  49.  
  50. (define-simple-switch load-noisily? boolean? t)
  51. (define-simple-switch source-file-extension symbol? 't)
  52. (define-simple-switch print-load-message? boolean? t)
  53.  
  54. ;;; Someday make the ENV-OPTION be not optional.
  55.  
  56. (define (load spec . env-option)
  57.   (load-aux load            spec env-option t   (load-noisily?)))
  58.  
  59. (define (load-if-present spec . env-option)
  60.   (load-aux load-if-present spec env-option nil (load-noisily?)))
  61.  
  62. (define (load-noisily spec . env-option)
  63.   (load-aux load-noisily    spec env-option t   t))
  64.  
  65. (define (load-quietly spec . env-option)
  66.   (load-aux load-quietly    spec env-option t nil))
  67.  
  68. (define (load-quietly-if-present spec . env-option)
  69.   (load-aux load-quietly-if-present spec env-option nil nil))
  70.  
  71. (define (load-silently spec . env-option)
  72.   (bind (((print-load-message?) nil)
  73.          ((print-env-warnings?) nil))
  74.     (load-aux load-silently spec env-option t nil)))
  75.  
  76. (define (load-silently-if-present spec . env-option)
  77.   (bind (((print-load-message?) nil)
  78.          ((print-env-warnings?) nil))
  79.     (load-aux load-silently-if-present spec env-option nil nil)))
  80.  
  81. ;;; Deal with defaulting of second arg.  T has no &optionals.
  82.  
  83. (lset +load-noisily?+ t)
  84.  
  85. (define (load-aux load spec env-option complain-if-missing? noisily?)
  86.   (bind ((+load-noisily?+ noisily?))
  87.     (let ((env (cond ((null? env-option) nil)
  88.                      (else
  89.                       (cond ((not (null? (cdr env-option)))
  90.                              ;; There ought to be some clean way to do
  91.                              ;; optional arguments in t.
  92.                              (error "too many arguments~%  ~s"
  93.                                     `(,(identification load)
  94.                                        ,spec
  95.                                        ,@env-option))))
  96.                       (car env-option)))))
  97.       (load-file spec env complain-if-missing?))))
  98.  
  99. ;;; Fills in an extension if one wasn't supplied, and loads the file.
  100. ;;; If the SPEC is a string then no extension is filled in.
  101.  
  102. (define (load-file filespec env complain?)
  103.   (with-open-ports ((port (open-default-filename filespec complain?)))
  104.     (cond ((port? port)
  105.            (if (iob? port) (set (iob-id port) (port-truename port)))
  106.            (load-port port (or env (repl-env))))
  107.           (else nil))))
  108.  
  109. (lset *load-level* 0)
  110.  
  111. (define (load-port port env)
  112.   (let ((name (port-name port)))
  113.     (print-load-message name env (loaded? (port-name port) env))
  114.     (bind ((*load-level* (fx+ *load-level* 1)))
  115.       (let* ((ftype (filename-type (->filename name)))
  116.              (ftype (if (string? ftype) 
  117.                         (string->symbol (string-upcase ftype))
  118.                         ftype))
  119.             ;++ this will become (read port)
  120.              (form  (cond ((eq? ftype (object-file-type (local-machine)))
  121.                            (let ((comex (read-comex port)))
  122.                              (set (loaded-modules port) comex)
  123.                              comex))
  124.                           (else (read port)))))
  125. ;        (check-compatibility port herald env)
  126.         (if (comex? form) 
  127.             (instantiate-comex form env name)
  128.             (instantiate-source port form env))))))
  129.                                                              
  130. ;++ INSTANTIATE-COMEX and INSTANTIATE-SOURCE (bad name) will
  131. ;++ have the same interface eventually and LOAD-PORT will be
  132. ;++ cleaned up.
  133.  
  134.  
  135.  
  136. (define (instantiate-comex comex env . id)
  137.   (let* ((id     (if (null? id) nil (car id)))
  138.          (h      (vref (comex-objects comex) 1))
  139.          (herald (parse-herald (car h) (cdr h)))
  140.      (version (comex-module-name comex)))
  141.     (if (not (and (number? version) (= version version-number)))
  142.     (error "Obsolete object file ~s" (herald-filename herald)))
  143.     (receive (unit code) (install-comex comex env)
  144.       (set (weak-table-entry code-unit-table code) unit)
  145.       (add-to-population code-population code)
  146.       (if id (set (loaded-file env id) (AUGMENT-UNIT unit ID)))
  147.       (run-compiled-code unit env))))
  148.  
  149. (define (instantiate-source port form env)
  150.   (receive (h port)
  151.            (cond ((and (pair? form) (eq? (car form) 'herald))
  152.                   (let ((h (parse-herald (cadr form) (cddr form))))
  153.                     (cond ((herald-read-table h)
  154.                            => (lambda (rt)
  155.                                 (set (port-read-table port)
  156.                                      (eval rt env)))))
  157.                     (return h port)))
  158.                  (else
  159.                   ;++(warning "file ~S has no HERALD form.~%"
  160.                   ;++         (port-name port))
  161.                   (return (make-default-herald (port-name port))
  162.                           (cons-port form port))))
  163.     (check-compatibility port h env)
  164.     (let ((unit (standard-compile-port port (get-target-syntax h env) h)))
  165.       (if (port-name port) (set (loaded-file env (port-name port)) (AUGMENT-UNIT unit (PORT-NAME PORT))))
  166.       (run-compiled-code unit env))))
  167.  
  168.  
  169. ;;; Random utilities for above.
  170.  
  171. ;;; Given a compiled code object, return the environment into which
  172. ;;; it believes it would like to be loaded, by evaluating the ENV
  173. ;;; clause from the object's HERALD structure.
  174. ;++ Note: This is slightly changed from 2.9.  The loader tries to
  175. ;++       load the code into one of ENV, TARGET-ENV, or REPL-ENV
  176. ;++       in that order.
  177.  
  178. (define (get-target-syntax herald env)
  179.   (cond ((herald-syntax-table herald)
  180.          => (lambda (st) (eval st env)))
  181.         (else
  182.          (env-syntax-table env))))
  183.  
  184. ;;; Modules
  185.  
  186. ;;; A module is an object which represents a partially evaluated
  187. ;;; expression.  When a module is instantiated its free variables
  188. ;;; are bound in the environment in which the module is instantiated.
  189. ;;; A module can be instantiated in more than one environment in
  190. ;;; which case the pure part of the module is shared.
  191.  
  192. (define loaded-modules
  193.   (let ((table (make-weak-table 'loaded-module-table)))
  194.     (object (lambda (port)
  195.               (let ((entry (weak-table-entry table (port-name port))))
  196.                 (return (car entry) (cdr entry))))
  197.       ((setter self)
  198.        (lambda (port module)
  199.          (set (weak-table-entry table (port-name port))
  200.               (cons (file-write-date port) module)))))))
  201.  
  202. (define (loaded? name env)
  203.   (let ((id (cond ((string? name) name)
  204.                   ((filename? name) (filename->string name))
  205.                   ((port? name)     (port-name name))
  206.                   (else
  207.                    (error "invalid identifier for file - ~a" name)))))
  208.     (true? (loaded-file env (FILENAME->STRING (EXPAND-FILENAME (->FILENAME id)))))))
  209.  
  210. ;;; Check to see if the module is loaded into the environment
  211. ;;; and if so check to see that it hasn't been modified.
  212.  
  213. (define (open-default-filename filespec complain?)
  214.   (let ((open (if complain? open maybe-open))
  215.         (fname (GET-DEFAULT-FILENAME filespec)))
  216.      (OPEN FNAME 'IN)))
  217.  
  218. (define (get-default-filename filespec)
  219.    (let* ((fname  (->filename filespec))
  220.           (ftype  (filename-type fname))
  221.           (src    (filename-with-type fname (source-file-extension)))
  222.           (bin    (filename-with-type fname (object-file-type (local-machine)))))
  223.      (cond ((or (string? filespec) (not (null? ftype)))
  224.             fname)
  225.            ((file-exists? bin)
  226.             (xcase (load-out-of-date-action)
  227.                ((binary) bin)
  228.                ((source) src)
  229.                ((newer)  (if (and (file-exists? src) (file-newer? src bin))
  230.                              src
  231.                              bin))
  232.                ((recompile) (if (and (file-exists? src) (file-newer? src bin))
  233.                                 (if (maybe-comfile src bin) bin src)
  234.                                 bin))
  235.                ((warn) (if (and (file-exists? src) (file-newer? src bin))
  236.                            (if (print-load-message?)
  237.                                (let ((msg-port (standard-output)))
  238.                                   (comment-indent msg-port (fx* *load-level* 2))
  239.                                   (format msg-port "~&Warning: ~a has changed since it was last compiled~%" src)
  240.                                   (force-output msg-port))))
  241.                        bin)
  242.                ((query) (if (and (file-exists? src) (file-newer? src bin)
  243.                                  (yes-or-no? "~&File ~a is out of date.  Recompile " src))
  244.                              (if (maybe-comfile src bin) bin src)
  245.                              bin))))
  246.            (else src))))
  247.           
  248. (define (maybe-comfile src bin)
  249.    (cond ((maybe-open bin '(out))  ;; hack!
  250.           => (lambda (port)
  251.                 (close port)
  252.                 (comfile src)
  253.                 '#t))
  254.          (else (if (print-load-message?)
  255.                    (let ((msg-port (standard-output)))
  256.                      (comment-indent msg-port (fx* *load-level* 2))
  257.                      (format msg-port "~&Can't compile ~a~%" (filename->string src))
  258.                      (force-output msg-port)))
  259.                '#f)))
  260.  
  261.  
  262. (define-simple-switch load-out-of-date-action
  263.                       (lambda (sym)
  264.                          (case sym
  265.                             ((binary)    t)    
  266.                             ((source)    t)
  267.                             ((query)     t)
  268.                             ((recompile) t)
  269.                             ((WARN)      T)
  270.                             ((NEWER)     T)
  271.                             (else        nil)))
  272.                       'warn)
  273.  
  274. ;++ where does this belong?
  275.  
  276. (define (yes-or-no? fmt . args)
  277.   (iterate loop ()
  278.     (apply prompt (standard-output) `(,fmt " (Y/N)? ") args)
  279.     (let ((val (read (standard-input))))
  280.       (case val
  281.         ((yes y) '#t)
  282.         ((no  n) '#f)
  283.         (else
  284.          (format t ";** Invalid response (~a)." val)
  285.          (loop))))))
  286.  
  287. (define (check-compatibility port herald env) (no-value))
  288.  
  289. (comment
  290.   (define (check-compatibility port herald env)
  291.     (let ((pname (->filename (port-name port)))
  292.           (hname (herald-filename herald)))
  293.       (cond ((not (filenames-compatible? pname hname))
  294.              (warning (list "(HERALD ~s ...)~%"
  295.                             ";**~12tdoesn't match (LOAD ~s ...)~%")
  296.                       hname
  297.                       pname))))
  298.     (let ((target (herald-environment herald)))
  299.       (if target
  300.           (let ((target-env (eval target env)))
  301.             (if (neq? target-env env)
  302.                 (warning (list "(HERALD ... (ENV ~a) ...)~%"
  303.                                ";**~12tdoesn't match (LOAD ... ~a)~%")
  304.                          target-env
  305.                          env)))))
  306.     (no-value))
  307.  )
  308. ;;; The screw case for ancient REQUIRE's is F1 = FOO and F2 =
  309. ;;; "~bar/foo.t"
  310.  
  311. (define (filenames-compatible? f1 f2)
  312.   (or (null? f1)
  313.       (null? f2)
  314.       (and (alikev? (filename-name f1) (filename-name f2))
  315.            (let ((d1 (filename-dir  f1))
  316.                  (d2 (filename-dir  f2)))
  317.              (or (null? d1)
  318.                  (null? d2)
  319.                  (alikev? d1 d2))))
  320.       (and (null? (filename-dir f1))
  321.            (string? (filename-name f1)))
  322.       (and (null? (filename-dir f2))
  323.            (string? (filename-name f2)))))
  324.  
  325. (define (print-load-message name env reloading?)
  326.   (cond ((print-load-message?)
  327.          (let ((out (standard-output)))  ; foo
  328.            (comment-indent out (fx* *load-level* 2))
  329.            (format out "~a ~a into ~a~%"
  330.                    (if reloading? "Reloading " "Loading ")
  331.                    name
  332.                    ;; Hack to make message more concise
  333.                    (or (print-info env) env))
  334.            (force-output out))))
  335.   (no-value))
  336.  
  337. ;;; Print value loaded.  Called by STANDARD-COMPILE-port.
  338.  
  339. (define (load-print vals)
  340.   (cond (+load-noisily?+
  341.          (let ((out (standard-output)))
  342.            (walk (lambda (val)
  343.                    (cond ((not (repl-wont-print? val))
  344.                           (print (or (identification val) val) out)
  345.                           (space out)))
  346.                    (no-value))
  347.                  vals)
  348.            (force-output out)))))
  349.  
  350. ;++ flush REQUIRE this later.
  351.  
  352. ;;; (*REQUIRE id spec env) - calls to this result from expansions
  353. ;;;  of REQUIRE forms.
  354. ;;; Make this smarter some day.
  355.  
  356. ;++ where is this used?
  357. ;(define *module-population* (make-population '*module-population*))
  358.  
  359. (define *base-support-env* t-implementation-env)
  360. (define *standard-support-env* standard-env)
  361.  
  362. (define (*require id filespec env)
  363.    (let ((fname (EXPAND-FILENAME (GET-DEFAULT-FILENAME filespec))))
  364.       (cond ((AND (loaded? fname env)
  365.                   (SAME-AS-BEFORE? FNAME ENV))
  366.              (cond ((print-load-message?)
  367.                     (let ((msg-port (standard-output)))
  368.                       (comment-indent msg-port (fx* *load-level* 2))
  369.                       (format msg-port "Already loaded ~a~%" (FILENAME->STRING fname))
  370.                       (force-output msg-port))))
  371.              (undefined-value "File already loaded"))
  372.             (else
  373.              (load-file (FILENAME->STRING fname) env t)))))
  374.  
  375. (define-operation (unit-write-date unit)
  376.    0)
  377.  
  378. (define (augment-unit unit id)
  379.    (let ((write-date (if (null? id) 0 (file-write-date id))))
  380.       (join (object nil ((unit-write-date self) write-date))
  381.             unit)))
  382.  
  383. ;; This code duplicates some of LOADED?, but rather than hack LOADED? I separated this out
  384. ;; since I don't know what else depends on LOADED?.
  385.  
  386. (define (same-as-before? name env)
  387.    (let* ((fname (expand-filename
  388.                     (->filename
  389.                      (cond ((string? name)   name)
  390.                            ((filename? name) (filename->string name))
  391.                            ((port? name)     (port-name name))
  392.                            (else
  393.                             (error "invalid identifier for file - ~a" name))))))
  394.           (id (filename->string fname))
  395.           (unit (loaded-file env id)))
  396.        (cond ((> (file-write-date fname) (unit-write-date unit))
  397.               (cond ((print-load-message?)
  398.                      (let ((msg-port (standard-output)))
  399.                        (comment-indent msg-port (fx* *load-level* 2))
  400.                        (format msg-port "~a has changed since it was loaded~%" id)
  401.                         (force-output msg-port))))
  402.               '#f)
  403.              (else '#t))))
  404.  
  405.  
  406.